PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/win/pascal/modal.exe/MODAL.PAS

Pascal/Delphi Source File | 1993-05-23 | 8.4 KB | 390 lines

unit modal;

(*
   This unit implements following objects

      T_CWINDOW       Makes it easy to create windows with a new window
                      class without overriding GetClassName and
                      GetWindowClass functions.  You specify the new class
                      name in the call to the init constructor.  You can
                      make all the class attribute changes in the init
                      constructor also.  It is derived from TWindow object.

      T_MODALWINDOW   This object allows you to create modal windows which
                      behave like a dialog box.  It will let you create
                      dialog boxes of your own without having to create a
                      dialog resource first.  You can easily create a window
                      with any OWL controls you want, dynamically, and use
                      it as a dialog box.

   This units also implements some related function to translate dialog
   units into screen units etc.  It also contains TBGroupBox and TBStatic
   to use BWCC specific featues.

   Copyright (c) 1993 by Yasser Asmi  (CIS 71543,2252)
   All rights reserved.

   If you have any questions or comments, please contact me either at
   CIS 71543,2252 or at the following address.  Thank you.

                                Yasser Asmi
                                400 W. Union, #6
                                Edwardsville, IL 62025
*)

{$A+,I-,R-,S-,V-,B-,G+,X+,W-}

interface

uses
   wintypes, winprocs, win31, strings, objects, owindows, odialogs, bwcc;

type
   p_cwindow = ^t_cwindow;
   t_cwindow = object (twindow)
      cwndclass : twndclass;
      cclassname : pchar;

      constructor init (aparent : pwindowsobject;
                        atitle : pchar;
                        aclassname : pchar);
      function getclassname : pchar; virtual;
      procedure getwindowclass (var awndclass : twndclass); virtual;
      destructor done; virtual;
   end;

   p_modalwindow = ^t_modalwindow;
   t_modalwindow = object (t_cwindow)
      noclose : boolean;
      complete : boolean;
      retval : integer;

      constructor init (aparent : pwindowsobject;
                        atitle : pchar;
                        aclassname : pchar);
      procedure setupwindow; virtual;
      function canclose : boolean; virtual;
      procedure b_ok (var msg : tmessage); virtual id_first + id_ok;
      procedure b_cancel (var msg : tmessage); virtual id_first + id_cancel;
      procedure wmclose (var msg : tmessage); virtual wm_first + wm_close;
      procedure endwin (aretval : integer);
      procedure disablekbhandler;
      procedure beginmodal;
      procedure endmodal;

   private
      lastmodal : pwindowsobject;
      lastfocus : hwnd;
   end;

   pbgroupbox = ^tbgroupbox;
   tbgroupbox = object (tgroupbox)
      constructor init (aparent : pwindowsobject;
                        anid : integer;
                        atext : pchar;
                        x, y, w, h : integer);
      function getclassname : pchar; virtual;
   end;

   pbstatic = ^tbstatic;
   tbstatic = object (tstatic)
      function getclassname : pchar; virtual;
   end;


function run_modal (p : p_modalwindow;
                    calldone : boolean) : integer;  (* see proc *)
procedure handlemessage;
function getprogwin : pwindow;                      (* get program window *)
function dux (x : integer) : integer;               (* dialog units to screen *)
function duy (y : integer) : integer;
procedure center_wa (var attr : twindowattr;        (* center window attr *)
                     w, h : integer);


implementation

const
   curmodalp : pwindowsobject = nil;


(*-- T_CWINDOW --*)

constructor t_cwindow.init;

begin
   inherited init (aparent, atitle);
   cclassname := strnew (aclassname);
   inherited getwindowclass (cwndclass);
   cwndclass.lpszclassname := cclassname;
end;


destructor t_cwindow.done;

begin
   strdispose (cclassname);
   inherited done;
end;


function t_cwindow.getclassname;

begin
   getclassname := cclassname;
end;


procedure t_cwindow.getwindowclass;

begin
   awndclass := cwndclass;
end;


(*-- T_MODALWINDOW --*)

constructor t_modalwindow.init;

begin
   inherited init (aparent, atitle, aclassname);
   enablekbhandler;
   attr.style := ws_popup or ws_visible or ws_caption or ws_sysmenu;
   attr.exstyle := ws_ex_dlgmodalframe;

   noclose := false;
   complete := false;
end;


procedure t_modalwindow.setupwindow;

var
   mh : hmenu;

begin
   inherited setupwindow;

   mh := getsystemmenu (hwindow, false);
   deletemenu (mh, 5, mf_byposition);
   deletemenu (mh, 4, mf_byposition);
   deletemenu (mh, 3, mf_byposition);
   deletemenu (mh, 2, mf_byposition);
   deletemenu (mh, 0, mf_byposition);
   if noclose then
      enablemenuitem (mh, sc_close, mf_disabled + mf_grayed);

   if childlist <> nil then
      setfocus (childlist^.hwindow);
end;


function t_modalwindow.canclose;

begin
   canclose := not noclose;
end;


procedure t_modalwindow.disablekbhandler;

begin
   setflags (wb_kbhandler, false);
end;


procedure t_modalwindow.endwin;

begin
   if canclose then
   begin
      retval := aretval;
      complete := true;
   end;
end;


procedure t_modalwindow.b_ok;

begin
   endwin (id_ok);
end;


procedure t_modalwindow.b_cancel;

begin
   endwin (id_cancel);
end;


procedure t_modalwindow.wmclose;

begin
   b_cancel (msg);
end;


procedure t_modalwindow.beginmodal;

begin
   lastfocus := getfocus;
   if curmodalp = nil then
      lastmodal := getprogwin
   else
      lastmodal := curmodalp;
   enablewindow (parent^.hwindow, false);
   application^.makewindow (@self);
   curmodalp := @self;
end;


procedure t_modalwindow.endmodal;

(*
   does not call the done destructor
*)

begin
   enablewindow (parent^.hwindow, true);
   setfocus (lastfocus);
   curmodalp := lastmodal;
end;


(*-- TBGROUPBOX --*)

constructor tbgroupbox.init;

begin
   inherited init (aparent, anid, atext, x, y, w, h);
   attr.style := (attr.style and not bs_groupbox) or bss_group;
end;


function tbgroupbox.getclassname;

begin
   getclassname := shade_class;
end;


(*-- TBSTATIC --*)

function tbstatic.getclassname;

begin
   getclassname := static_class;
end;


(*-- PROCS --*)

function run_modal (p : p_modalwindow;
                    calldone : boolean) : integer;

(*
   If calldone=true then, the done destructor is called from this
   procedure after completion.  Otherwise, the caller must call the
   done destructor.
*)

begin
   p^.beginmodal;
   while not p^.complete do
      handlemessage;
   p^.endmodal;
   run_modal := p^.retval;
   if calldone then
      p^.done;
end;


function getprogwin : pwindow;

(*
   returns programs mainwindow or nil if application is nil
*)

begin
   if application = nil then
      getprogwin := nil
   else
      getprogwin := pwindow (application^.mainwindow);
end;


procedure handlemessage;

(*
  gets a message from the queue and processes it
  if the message is WM_KILLFOCUS it is not processed
*)

var
   m : tmsg;

begin
   if peekmessage (m, 0, 0, 0, pm_remove) then
   begin
      if not application^.processappmsg (m) then
      begin
         if m.message <> wm_killfocus then
         begin
            translatemessage (m);
            dispatchmessage (m);
         end
         else
            messagebeep (10);
      end;
   end;
end;


function dux (x : integer) : integer;

(*
   converts horizontal dialog units into screen unit
*)

begin
   dux := (x * loword (getdialogbaseunits)) div 4;
end;


function duy (y : integer) : integer;

(*
   converts vertical dialog units into screen unit
*)

begin
   duy := (y * hiword (getdialogbaseunits)) div 8;
end;


procedure center_wa (var attr : twindowattr;
                     w, h : integer);

(*
   Sets width and height fields in window attr to w and h
   and the centers the window on screen.  Call it from the
   init constructor of a window.
*)

 function cen (mw, w : integer) : integer;

 begin
    cen := (mw div 2) - (w div 2)
 end;

begin
   attr.w := w;
   attr.h := h;
   attr.x := cen (getsystemmetrics (sm_cxscreen), w);
   attr.y := cen (getsystemmetrics (sm_cyscreen), h);
end;


end.